home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PRINTER / PRBGI095.ARJ / BGIDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-17  |  49KB  |  1,715 lines
  1. {  This program is not mine.
  2.    It was included with Turbo Pascal 6.0
  3.    and I only modified it a little  to demonstrate
  4.    features of my PRINTBGI library.
  5.    It is included here for demonstration only
  6.    and cannot be used for any other purposes. ( Could it? ).
  7.  
  8.    Original Copyright notice follows.
  9. }
  10.  
  11. { Turbo Graphics }
  12. { Copyright (c) 1985, 1990 by Borland International, Inc. }
  13.  
  14. program BGIDemo;
  15. (*
  16.   Turbo Pascal 6.0 Borland Graphics Interface (BGI) demonstration
  17.   program. This program shows how to use many features of
  18.   the Graph unit.
  19.  
  20.   NOTE: to have this demo use the IBM8514 driver, specify a
  21.   conditional define constant "Use8514" (using the {$DEFINE}
  22.   directive or Options\Compiler\Conditional defines) and then
  23.   re-compile.
  24.  
  25. *)
  26.  
  27. uses
  28.   Crt, Dos, Graph, PRTgraph,Pdrivers;
  29.  
  30.  
  31. const
  32.   { The five fonts available }
  33.   Fonts : array[0..4] of string[13] =
  34.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  35.  
  36.   { The five predefined line styles supported }
  37.   LineStyles : array[0..4] of string[9] =
  38.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  39.  
  40.   { The twelve predefined fill styles supported }
  41.   FillStyles : array[0..11] of string[14] =
  42.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  43.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  44.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  45.  
  46.   { The two text directions available }
  47.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  48.  
  49.   { The Horizontal text justifications available }
  50.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  51.  
  52.   { The vertical text justifications available }
  53.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  54.  
  55. var
  56.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  57.  
  58. var
  59.   GraphDriver : integer;  { The Graphics device driver }
  60.   GraphMode   : integer;  { The Graphics mode value }
  61.   (* MaxX, MaxY  : word;  *)   { The maximum resolution of the screen }
  62.      function MaxX:integer;
  63.      begin MaxX:=getmaxX; end;
  64.      function MaxY:integer;
  65.      begin MaxY:=getmaxY; end;
  66. var
  67.   ErrorCode   : integer;  { Reports any graphics errors }
  68.   (* MaxColor    : word;   *)  { The maximum color value available }
  69.      function MaxColor:integer;
  70.      begin MaxColor:=getmaxColor; end;
  71. var
  72.   OldExitProc : Pointer;  { Saves exit procedure address }
  73.  
  74. {$F+}
  75. procedure MyExitProc;
  76. begin
  77.   ExitProc := OldExitProc; { Restore exit procedure address }
  78.   CloseGraph;              { Shut down the graphics system }
  79. end; { MyExitProc }
  80. {$F-}
  81.  
  82. VAR
  83.    PRTno:   word;
  84.    PRTmode:    integer;
  85.    OutName: PathStr;
  86. Const
  87.    picwidth    : integer = 4000;
  88.    picheight   : integer =3000;
  89.    leftmargin  : integer =0;
  90.    topmargin   : integer =0;
  91.    PicRotate   : integer =0;
  92.    PicInverse  : integer =1;
  93. {-------------------------------}
  94. Procedure ReadInt(var n: integer);
  95. {-------------------------------}
  96. var x: integer;
  97.     c: char;
  98. Begin
  99.    {$ifdef ver60 }
  100.       asm @@lp:;
  101.           mov  AH,1;   { nondestructive keyboard read }
  102.           int  $16;    { BIOS Kbd intr }
  103.           jz   @@lp;
  104.           mov  c,AL
  105.       end;
  106.       if c = ^M then
  107.       begin (* user pressed ENTER - don't change old value *)
  108.          c := ReadKey;
  109.          writeln(n);
  110.       end
  111.       else
  112.    {$endif }
  113.    begin
  114.       {$I- }
  115.       ReadLn(x);
  116.       {$I+ }
  117.       if IOresult = 0 then n:=x;
  118.    end;
  119. End;
  120. (*-----------------------*)
  121. Procedure AskOfParameters;
  122. (*-----------------------*)
  123. var
  124.    c: char;
  125.    MAXmode  : integer;
  126.    modename    : stringPtr;
  127.    rc          : integer;
  128. Begin
  129.    writeln;
  130.    writeln ( ' Choose printer mode operation' );
  131.    rc := PRT_MaxMode ( PRTno, MAXmode );
  132.    for PRTmode:=0 to MAXmode do
  133.    begin
  134.       {$V- }
  135.       rc := PRT_ModeName(PRTno,PRTmode,modename );
  136.       {$V+ }
  137.       writeln ( '        ', PRTmode:2,' - ', modename^ );
  138.    end;
  139.    PRTmode:=MAXmode+1;
  140.    repeat
  141.      c:=ReadKey;
  142.      if c=#0 then c:=ReadKey
  143.      else if ord(c)-ord('0') <= MAXmode then PRTmode := ord(c)-ord('0');
  144.    until  PRTmode <= MAXmode;
  145.  
  146.    writeln;
  147.    write ( ' Picture width in 1/1000 inch [', picwidth, '] ' );
  148.    ReadInt ( picwidth );
  149.    write ( ' Picture height in 1/1000 inch [', picheight, '] ' );
  150.    ReadInt ( picheight );
  151.  
  152.    write ( ' Top margin in 1/1000 inch [', topmargin, '] '  );
  153.    ReadInt ( topmargin );
  154.    write ( ' Left margin in 1/1000 inch [', leftmargin, '] ' );
  155.    ReadInt ( leftmargin );
  156.    write ( ' Rotate picture [', PicRotate, '] ' );
  157.    ReadInt ( PicRotate );
  158.    write ( ' Inverse picture [', PicInverse, '] ' );
  159.    ReadInt ( PicInverse );
  160. End;
  161.  
  162. CONST
  163.    printing: boolean=false;
  164.    asking:   boolean=false;
  165. var
  166.    PRT_drv: integer;
  167.  
  168. (*---------------------------------*)
  169. Procedure DrawAndPrint ( func: DrawFuncT );
  170. (*---------------------------------*)
  171. const
  172.    Seed = 1964;
  173. var
  174.    rc  : integer;
  175.    PRT_mode,mode: integer;
  176.    PicMode  : integer;
  177.    c: char;
  178. Begin
  179.    PRT_mode := 0;
  180.    repeat
  181.       asking:=false;
  182.       printing:=false;
  183.       RandSeed := Seed;
  184.       rc:=func(nil);
  185.       if asking then
  186.       begin
  187.          mode := getgraphmode;
  188.          restorecrtmode;
  189.          AskOfParameters;
  190.          setgraphmode( mode );
  191.       end;
  192.       if ( printing ) then   (* Have user pressed Ctrl-P ? *)
  193.       begin
  194.          RandSeed := Seed;
  195.          PicMode := 0;
  196.          if PicRotate<>0 then PicMode := PicMode or PRT_ROTATE;
  197.          if PicInverse<>0 then PicMode := PicMode or PRT_INVERSE;
  198.             rc:=PRT_SetDriver ( PRTno, PRTmode,picwidth,picheight, PicMode );
  199.          rc:=PRT_SetMargins ( leftmargin, topmargin );
  200.          rc:=PRT_PrintBGI ( PRT_drv, PRT_mode, PathToDriver, func, nil );
  201.          if ( rc<>0 ) then
  202.          begin
  203.             mode:=getgraphmode;
  204.             restorecrtmode;
  205.             writeln ( ' error code ', rc, ' (', PRT_errormsg(rc),
  206.                       ') from PRT_PrintBGI ' );
  207.             c:=ReadKey; while KeyPressed do c:=ReadKey;
  208.             setgraphmode(mode);
  209.          end;
  210.          if (PRT_DriverNo>=LaserJet) then    (* form feed for laser printers *)
  211.          begin
  212.             mode := getgraphmode;
  213.             restorecrtmode;
  214.             rc:=PRT_Send(#$0C);    (*Form Feed*)
  215.             setgraphmode(mode);
  216.             rc:=graphresult;
  217.          end;
  218.       end;
  219.    until ( not asking  and  not printing );
  220.  
  221. End;
  222.  
  223. (*-----------------*)
  224. Procedure  PRT_Initialize;
  225. (*-----------------*)
  226. var
  227.    PRTname:    stringPtr;
  228.    s:          PathStr;
  229.    MaxPrinterNo: word;
  230.    rc:         integer;
  231.    c:          char;
  232. Begin
  233.    OutName := 'PRN';
  234.    MaxPrinterNo := PRT_MaxDriver;
  235.    clrscr;
  236.    writeln;
  237.    writeln ( 'This is a sample program (developed from Borland''s BGIDEMO.PAS)' );
  238.    writeln ( 'demonstrating some of the features of PrintBGI toolkit' );
  239.    writeln ( 'Hope you''ll find it usefull (the whole package not this program,' );
  240.    writeln ( 'of course).' );
  241.    writeln;
  242.    writeln ( 'Please, let me know if this program does not work with your printer.');
  243.    writeln ( 'To contact me write to RESZTAK@PLUMCS11.bitnet');
  244.    writeln;
  245.    writeln ( '              Press any key to continue');
  246.    c:=ReadKey; while KeyPressed do c:=ReadKey;
  247.    clrscr;
  248.  
  249.    writeln ( '    Choose printer type' );
  250.    writeln;
  251.    for PRTno:=0 to MaxPrinterNo do
  252.    begin
  253.       rc := PRT_DriverName(PRTno,PRTname);
  254.       writeln ( '        ', PRTno, ' - ', PRTname^ );
  255.    end;
  256.    repeat
  257.       Readln(PRTno);
  258.    until ( PRTno<=MaxPrinterNo );
  259.  
  260.    clrscr;
  261.    write ( ' Output device name [', OutName, '] ' );
  262.    ReadLn ( s ); if length(s)<>0 then OutName:=s;
  263.  
  264.    clrscr;
  265.    PRT_drv := Detect; { needed if you don't want to link BitImage driver }
  266.    PRT_drv := PRT_installuserdriver ( 'BitImage', NIL );
  267.    rc := PRT_registerbgidriver ( @BitImage );
  268.  
  269.    AskOfParameters;
  270.    writeln;
  271.    writeln ( ' You will be able to change above parameters by pressing Ctrl-C.' );
  272.    writeln;
  273.    writeln ( '                   Press any key to continue');
  274.    c:=ReadKey;while KeyPressed do c:=ReadKey;
  275.  
  276.    rc := PRT_SetOutName ( OutName );
  277. End;
  278.  
  279.  
  280.  
  281. procedure Initialize;
  282. { Initialize graphics and report any errors that may occur }
  283. var
  284.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  285. begin
  286.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  287.   DirectVideo := False;
  288.   OldExitProc := ExitProc;                { save previous exit proc }
  289.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  290.   PathToDriver := getenv('BGIpath');
  291.   repeat
  292.  
  293. {$IFDEF Use8514}                          { check for Use8514 $DEFINE }
  294.     GraphDriver := IBM8514;
  295.     GraphMode := IBM8514Hi;
  296. {$ELSE}
  297.     GraphDriver := Detect;                { use autodetection }
  298. {$ENDIF}
  299.  
  300.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  301.     ErrorCode := GraphResult;             { preserve error return }
  302.     if ErrorCode <> grOK then             { error? }
  303.     begin
  304.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  305.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  306.       begin
  307.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  308.         Readln(PathToDriver);
  309.         Writeln;
  310.       end
  311.       else
  312.         Halt(1);                          { Some other error: terminate }
  313.     end;
  314.   until ErrorCode = grOK;
  315.   Randomize;                { init random number generator }
  316.   (************************************************************
  317.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  318.   MaxX := GetMaxX;          { Get screen resolution values }
  319.   MaxY := GetMaxY;
  320.   *************************************************************)
  321. end; { Initialize }
  322.  
  323. function Int2Str(L : LongInt) : string;
  324. { Converts an integer to a string for use with OutText, OutTextXY }
  325. var
  326.   S : string;
  327. begin
  328.   Str(L, S);
  329.   Int2Str := S;
  330. end; { Int2Str }
  331.  
  332. function RandColor : word;
  333. { Returns a Random non-zero color value that is within the legal
  334.   color range for the selected device driver and graphics mode.
  335.   MaxColor is set to GetMaxColor by Initialize }
  336. begin
  337.   RandColor := Random(MaxColor)+1;
  338. end; { RandColor }
  339.  
  340. procedure DefaultColors;
  341. { Select the maximum color in the Palette for the drawing color }
  342. begin
  343.   SetColor(MaxColor);
  344. end; { DefaultColors }
  345.  
  346. procedure DrawBorder;
  347. { Draw a border around the current view port }
  348. var
  349.   ViewPort : ViewPortType;
  350. begin
  351.   DefaultColors;
  352.   SetLineStyle(SolidLn, 0, NormWidth);
  353.   GetViewSettings(ViewPort);
  354.   with ViewPort do
  355.     Rectangle(0, 0, x2-x1, y2-y1);
  356. end; { DrawBorder }
  357.  
  358. procedure FullPort;
  359. { Set the view port to the entire screen }
  360. begin
  361.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  362. end; { FullPort }
  363.  
  364. Procedure ChangeTextStyle(font, direction, charsize: integer);
  365. var
  366.   m:     integer;
  367.   x,y:   integer;
  368.   rc:    integer;
  369. Begin
  370.   rc := graphresult;        { clear error code }
  371.   if printing and (font=DEFAULTFONT)  then
  372.   begin
  373.       rc := PRT_Resolution ( x,y );
  374.       m := y+60 div 120;
  375.       if m > MaxX div 600+1 then m := MaxX div 600+1;
  376.       if m>1 then charsize :=charsize*m;
  377.   end;
  378.   settextstyle(font, direction, charsize);
  379. End; { ChangeTextStyle }
  380.  
  381.  
  382. procedure MainWindow(Header : string);
  383. { Make a default window and view port for demos }
  384. begin
  385.   DefaultColors;                           { Reset the colors }
  386.   ClearDevice;                             { Clear the screen }
  387.   ChangeTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  388.   SetTextJustify(CenterText, TopText);     { Left justify text }
  389.   FullPort;                                { Full screen view port }
  390.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  391.   { Draw main window }
  392.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  393.   DrawBorder;                              { Put a border around it }
  394.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  395.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  396. end; { MainWindow }
  397.  
  398. procedure StatusLine(Msg : string);
  399. { Display a status line at the bottom of the screen }
  400. begin
  401.   FullPort;
  402.   DefaultColors;
  403.   ChangeTextStyle(DefaultFont, HorizDir, 1);
  404.   SetTextJustify(CenterText, TopText);
  405.   SetLineStyle(SolidLn, 0, NormWidth);
  406.   SetFillStyle(EmptyFill, 0);
  407.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  408.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  409.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  410.   { Go back to the main window }
  411.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  412. end; { StatusLine }
  413.  
  414. procedure WaitToGo;
  415. { Wait for the user to abort the program or continue }
  416. const
  417.   Esc = #27;
  418. var
  419.   Ch : char;
  420. begin
  421.   StatusLine('Esc aborts, Ctrl-P prints, other key continue');
  422.   if not printing then
  423.   begin
  424.      Ch := ReadKey;
  425.      case Ch of
  426.          Esc:  Halt(0);                           { terminate program }
  427.          ^P:   printing:=true;
  428.          ^C:   asking:=true;
  429.          else
  430.           ClearDevice;                      { clear screen, go on with demo }
  431.      end;
  432.      if ch = #0 then ch := readkey;      { trap function keys }
  433.   end;
  434. end; { WaitToGo }
  435.  
  436. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  437. { Return strings describing the current device driver and graphics mode
  438.   for display of status report }
  439. begin
  440.   DriveStr := GetDriverName;
  441.   ModeStr := GetModeName(GetGraphMode);
  442. end; { GetDriverAndMode }
  443.  
  444. {$F+ <-------------------------------- }
  445.  
  446. Function ReportStatus(UserPointer: pointer): integer;
  447. { Display the status of all query functions after InitGraph }
  448. const
  449.   X = 10;
  450. var
  451.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  452.   LineInfo   : LineSettingsType;
  453.   FillInfo   : FillSettingsType;
  454.   TextInfo   : TextSettingsType;
  455.   Palette    : PaletteType;
  456.   DriverStr  : string;           { Driver and mode strings }
  457.   ModeStr    : string;
  458.   Y          : word;
  459.  
  460. procedure WriteOut(S : string);
  461. { Write out a string and increment to next line }
  462. begin
  463.   OutTextXY(X, Y, S);
  464.   Inc(Y, TextHeight('M')+2);
  465. end; { WriteOut }
  466.  
  467. begin { ReportStatus }
  468.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  469.   GetViewSettings(ViewInfo);
  470.   GetLineSettings(LineInfo);
  471.   GetFillSettings(FillInfo);
  472.   GetTextSettings(TextInfo);
  473.   GetPalette(Palette);
  474.  
  475.   Y := 4;
  476.   MainWindow('Status report after InitGraph');
  477.   SetTextJustify(LeftText, TopText);
  478.   WriteOut('Graphics device    : '+DriverStr);
  479.   WriteOut('Graphics mode      : '+ModeStr);
  480.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  481.   with ViewInfo do
  482.   begin
  483.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  484.     if ClipOn then
  485.       WriteOut('Clipping           : ON')
  486.     else
  487.       WriteOut('Clipping           : OFF');
  488.   end;
  489.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  490.   WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  491.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  492.   WriteOut('Current color      : '+Int2Str(GetColor));
  493.   with LineInfo do
  494.   begin
  495.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  496.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  497.   end;
  498.   with FillInfo do
  499.   begin
  500.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  501.     WriteOut('Current fill color : '+Int2Str(Color));
  502.   end;
  503.   with TextInfo do
  504.   begin
  505.     WriteOut('Current font       : '+Fonts[Font]);
  506.     WriteOut('Text direction     : '+TextDirect[Direction]);
  507.     WriteOut('Character size     : '+Int2Str(CharSize));
  508.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  509.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  510.   end;
  511.   WaitToGo;
  512.   ReportStatus := 0;
  513. end; { ReportStatus }
  514.  
  515. function FillEllipsePlay(UserPointer: pointer): integer;
  516. { Random filled ellipse demonstration }
  517. const
  518.   MaxFillStyles = 12; { patterns 0..11 }
  519. var
  520.   MaxRadius : word;
  521.   FillColor : integer;
  522.   _i        : integer;
  523. begin
  524.   MainWindow('FillEllipse Demostration');
  525.   { StatusLine('Esc aborts or press a key'); }
  526.   MaxRadius := MaxY div 10;
  527.   SetLineStyle(SolidLn, 0, NormWidth);
  528.   for _i:=1 to 40 do
  529.   begin
  530.     FillColor := RandColor;
  531.     SetColor(FillColor);
  532.     SetFillStyle(Random(MaxFillStyles), FillColor);
  533.     FillEllipse(Random(MaxX), Random(MaxY),
  534.                 Random(MaxRadius), Random(MaxRadius));
  535.   end;
  536.   WaitToGo;
  537.   FillEllipsePlay := 0;
  538. end; { FillEllipsePlay }
  539.  
  540. function SectorPlay(UserPointer: pointer): integer;
  541. { Draw random sectors on the screen }
  542. const
  543.   MaxFillStyles = 12; { patterns 0..11 }
  544. var
  545.   MaxRadius : word;
  546.   FillColor : integer;
  547.   EndAngle  : integer;
  548.   _i_       : integer;
  549. begin
  550.   MainWindow('Sector Demostration');
  551.   { StatusLine('Esc aborts or press a key'); }
  552.   MaxRadius := MaxY div 10;
  553.   SetLineStyle(SolidLn, 0, NormWidth);
  554.   for _i_:=1 to 40 do
  555.   begin
  556.     FillColor := RandColor;
  557.     SetColor(FillColor);
  558.     SetFillStyle(Random(MaxFillStyles), FillColor);
  559.     EndAngle := Random(360);
  560.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  561.            Random(MaxRadius), Random(MaxRadius));
  562.   end;
  563.   WaitToGo;
  564.   SectorPlay := 0;
  565. end; { SectorPlay }
  566.  
  567. function WriteModePlay(UserPointer: pointer): integer;
  568. { Demonstrate the SetWriteMode procedure for XOR lines }
  569. const
  570.   DelayValue = 50;  { milliseconds to delay }
  571. var
  572.   ViewInfo      : ViewPortType;
  573.   Color         : word;
  574.   Left, Top     : integer;
  575.   Right, Bottom : integer;
  576.   Step          : integer; { step for rectangle shrinking }
  577.   _i_           : integer;
  578. begin
  579.   MainWindow('SetWriteMode Demostration');
  580.   { StatusLine('Esc aborts or press a key'); }
  581.   GetViewSettings(ViewInfo);
  582.   Left := 0;
  583.   Top := 0;
  584.   with ViewInfo do
  585.   begin
  586.     Right := x2-x1;
  587.     Bottom := y2-y1;
  588.   end;
  589.   Step := Bottom div 50;
  590.   SetColor(GetMaxColor);
  591.   Line(Left, Top, Right, Bottom);
  592.   Line(Left, Bottom, Right, Top);
  593.   SetWriteMode(XORPut);                    { Set XOR write mode }
  594.   for _i_:=1 to 50 do
  595.   begin
  596.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  597.     Line(Left, Bottom, Right, Top);
  598.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  599.     Delay(DelayValue);                     { Wait }
  600.     Line(Left, Top, Right, Bottom);        { Erase lines }
  601.     Line(Left, Bottom, Right, Top);
  602.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  603.     if (Left+Step < Right) and (Top+Step < Bottom) then
  604.       begin
  605.         Inc(Left, Step);                  { Shrink rectangle }
  606.         Inc(Top, Step);
  607.         Dec(Right, Step);
  608.         Dec(Bottom, Step);
  609.       end
  610.     else
  611.       begin
  612.         Color := RandColor;                { New color }
  613.         SetColor(Color);
  614.         Left := 0;                         { Original large rectangle }
  615.         Top := 0;
  616.         with ViewInfo do
  617.         begin
  618.           Right := x2-x1;
  619.           Bottom := y2-y1;
  620.         end;
  621.       end;
  622.   end;
  623.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  624.   WaitToGo;
  625.   WriteModePlay := 0;
  626. end; { WriteModePlay }
  627.  
  628. function AspectRatioPlay(UserPointer: pointer): integer;
  629. { Demonstrate  SetAspectRatio command }
  630. var
  631.   ViewInfo   : ViewPortType;
  632.   CenterX    : integer;
  633.   CenterY    : integer;
  634.   Radius     : word;
  635.   Xasp, Yasp : word;
  636.   i          : integer;
  637.   RadiusStep : word;
  638. begin
  639.   MainWindow('SetAspectRatio Demostration');
  640.   GetViewSettings(ViewInfo);
  641.   with ViewInfo do
  642.   begin
  643.     CenterX := (x2-x1) div 2;
  644.     CenterY := (y2-y1) div 2;
  645.     Radius := 3*((y2-y1) div 5);
  646.   end;
  647.   RadiusStep := (Radius div 30);
  648.   Circle(CenterX, CenterY, Radius);
  649.   GetAspectRatio(Xasp, Yasp);
  650.   for i := 1 to 30 do
  651.   begin
  652.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  653.     Circle(CenterX, CenterY, Radius);
  654.     Dec(Radius, RadiusStep);                   { Shrink radius }
  655.   end;
  656.   Inc(Radius, RadiusStep*30);
  657.   for i := 1 to 30 do
  658.   begin
  659.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  660.     if Radius > RadiusStep then
  661.       Dec(Radius, RadiusStep);                 { Shrink radius }
  662.     Circle(CenterX, CenterY, Radius);
  663.   end;
  664.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  665.   WaitToGo;
  666.   AspectRatioPlay := 0;
  667. end; { AspectRatioPlay }
  668.  
  669. function TextPlay(UserPointer: pointer): integer;
  670. { Demonstrate text justifications and text sizing }
  671. var
  672.   Size : word;
  673.   W, H, X, Y : word;
  674.   ViewInfo : ViewPortType;
  675. begin
  676.   MainWindow('SetTextJustify / SetUserCharSize demo');
  677.   GetViewSettings(ViewInfo);
  678.   with ViewInfo do
  679.   begin
  680.     ChangeTextStyle(TriplexFont, VertDir, 4);
  681.     Y := (y2-y1) - 2;
  682.     SetTextJustify(CenterText, BottomText);
  683.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  684.     ChangeTextStyle(TriplexFont, HorizDir, 4);
  685.     SetTextJustify(LeftText, TopText);
  686.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  687.     SetTextJustify(CenterText, CenterText);
  688.     X := (x2-x1) div 2;
  689.     Y := TextHeight('H');
  690.     for Size := 1 to 4 do
  691.     begin
  692.       ChangeTextStyle(TriplexFont, HorizDir, Size);
  693.       H := TextHeight('M');
  694.       W := TextWidth('M');
  695.       Inc(Y, H);
  696.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  697.     end;
  698.     Inc(Y, H div 2);
  699.     SetTextJustify(CenterText, TopText);
  700.     SetUserCharSize(5, 6, 3, 2);
  701.     ChangeTextStyle(TriplexFont, HorizDir, UserCharSize);
  702.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  703.   end;
  704.   WaitToGo;
  705.   TextPlay := 0;
  706. end; { TextPlay }
  707.  
  708. var
  709.   Font : word;
  710. function TextDump2(UserPointer: pointer): integer;
  711. { Dump the complete character sets to the screen }
  712. const
  713.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  714.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  715. var
  716.   ViewInfo : ViewPortType;
  717.   Ch : char;
  718. begin
  719.     MainWindow(Fonts[Font]+' character set');
  720.     GetViewSettings(ViewInfo);
  721.     with ViewInfo do
  722.     begin
  723.       SetTextJustify(LeftText, TopText);
  724.       MoveTo(2, 3);
  725.       if Font = DefaultFont then
  726.         begin
  727.           ChangeTextStyle(Font, HorizDir, 1);
  728.           Ch := #0;
  729.           repeat
  730.             OutText(Ch);
  731.             if (GetX + TextWidth('M')) > (x2-x1) then
  732.               MoveTo(2, GetY + TextHeight('M')+3);
  733.             Ch := Succ(Ch);
  734.           until (Ch >= #255);
  735.         end
  736.       else
  737.         begin
  738.           if MaxY < 200 then
  739.             ChangeTextStyle(Font, HorizDir, CGASizes[Font])
  740.           else
  741.             ChangeTextStyle(Font, HorizDir, NormSizes[Font]);
  742.           Ch := '!';
  743.           repeat
  744.             OutText(Ch);
  745.             if (GetX + TextWidth('M')) > (x2-x1) then
  746.               MoveTo(2, GetY + TextHeight('M')+3);
  747.             Ch := Succ(Ch);
  748.           until (Ch >= #255);
  749.         end;
  750.     end; { with }
  751.     WaitToGo;
  752.     TextDump2 := 0;
  753. end; { TextDump2 }
  754.  
  755. procedure TextDump;
  756. { Dump the complete character sets to the screen }
  757. begin
  758.   for Font := 0 to 4 do
  759.   begin
  760.      DrawAndPrint(TextDump2);
  761.   end;
  762. end; {TextDump }
  763.  
  764. function LineToPlay(UserPointer: pointer): integer;
  765. { Demonstrate MoveTo and LineTo commands }
  766. const
  767.   MaxPoints = 15;
  768. var
  769.   Points     : array[0..MaxPoints] of PointType;
  770.   ViewInfo   : ViewPortType;
  771.   I, J       : integer;
  772.   CenterX    : integer;   { The center point of the circle }
  773.   CenterY    : integer;
  774.   Radius     : word;
  775.   StepAngle  : word;
  776.   Xasp, Yasp : word;
  777.   Radians    : real;
  778.  
  779. function AdjAsp(Value : integer) : integer;
  780. { Adjust a value for the aspect ratio of the device }
  781. begin
  782.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  783. end; { AdjAsp }
  784.  
  785. begin
  786.   MainWindow('MoveTo, LineTo Demostration');
  787.   GetAspectRatio(Xasp, Yasp);
  788.   GetViewSettings(ViewInfo);
  789.   with ViewInfo do
  790.   begin
  791.     CenterX := (x2-x1) div 2;
  792.     CenterY := (y2-y1) div 2;
  793.     Radius := CenterY;
  794.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  795.       Inc(Radius);
  796.   end;
  797.   StepAngle := 360 div MaxPoints;
  798.   for I := 0 to MaxPoints - 1 do
  799.   begin
  800.     Radians := (StepAngle * I) * Pi / 180;
  801.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  802.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  803.   end;
  804.   Circle(CenterX, CenterY, Radius);
  805.   for I := 0 to MaxPoints - 1 do
  806.   begin
  807.     for J := I to MaxPoints - 1 do
  808.     begin
  809.       MoveTo(Points[I].X, Points[I].Y);
  810.       LineTo(Points[J].X, Points[J].Y);
  811.     end;
  812.   end;
  813.   WaitToGo;
  814.   LineToPlay :=0;
  815. end; { LineToPlay }
  816.  
  817. function LineRelPlay(UserPointer: pointer): integer;
  818. { Demonstrate MoveRel and LineRel commands }
  819. const
  820.   MaxPoints = 12;
  821. var
  822.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  823.   CurrPort : ViewPortType;
  824.  
  825. procedure DrawTesseract;
  826. { Draw a Tesseract on the screen with relative move and
  827.   line drawing commands, also create a polygon for filling }
  828. const
  829.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  830. var
  831.   X, Y, W, H   : integer;
  832.  
  833. begin
  834.   GetViewSettings(CurrPort);
  835.   with CurrPort do
  836.   begin
  837.     W := (x2-x1) div 9;
  838.     H := (y2-y1) div 8;
  839.     X := ((x2-x1) div 2) - round(2.5 * W);
  840.     Y := ((y2-y1) div 2) - (3 * H);
  841.  
  842.     { Border around viewport is outer part of polygon }
  843.     Poly[1].X := 0;     Poly[1].Y := 0;
  844.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  845.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  846.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  847.     Poly[5].X := 0;     Poly[5].Y := 0;
  848.     MoveTo(X, Y);
  849.  
  850.     { Grab the whole in the polygon as we draw }
  851.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  852.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  853.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  854.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  855.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  856.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  857.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  858.  
  859.     { Fill the polygon with a user defined fill pattern }
  860.     SetFillPattern(CheckerBoard, MaxColor);
  861.     FillPoly(12, Poly);
  862.  
  863.     MoveRel(W, -H);
  864.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  865.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  866.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  867.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  868.     LineRel(-W, 0);
  869.  
  870.     { Flood fill the center }
  871.     FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor);
  872.   end;
  873. end; { DrawTesseract }
  874.  
  875. begin
  876.   MainWindow('LineRel / MoveRel Demostration');
  877.   GetViewSettings(CurrPort);
  878.   with CurrPort do
  879.     { Move the viewport out 1 pixel from each end }
  880.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  881.   DrawTesseract;
  882.   WaitToGo;
  883.   LineRelPlay := 0;
  884. end; { LineRelPlay }
  885.  
  886. function PiePlay(UserPointer: pointer): integer;
  887. { Demonstrate  PieSlice and GetAspectRatio commands }
  888. var
  889.   ViewInfo   : ViewPortType;
  890.   CenterX    : integer;
  891.   CenterY    : integer;
  892.   Radius     : word;
  893.   Xasp, Yasp : word;
  894.   X, Y       : integer;
  895.  
  896. function AdjAsp(Value : integer) : integer;
  897. { Adjust a value for the aspect ratio of the device }
  898. begin
  899.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  900. end; { AdjAsp }
  901.  
  902. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  903. { Get the coordinates of text for pie slice labels }
  904. var
  905.   Radians : real;
  906. begin
  907.   Radians := AngleInDegrees * Pi / 180;
  908.   X := round(Cos(Radians) * Radius);
  909.   Y := round(Sin(Radians) * Radius);
  910. end; { GetTextCoords }
  911.  
  912. begin
  913.   MainWindow('PieSlice / GetAspectRatio Demostration');
  914.   GetAspectRatio(Xasp, Yasp);
  915.   GetViewSettings(ViewInfo);
  916.   with ViewInfo do
  917.   begin
  918.     CenterX := (x2-x1) div 2;
  919.     CenterY := ((y2-y1) div 2) + 20;
  920.     Radius := (y2-y1) div 3;
  921.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  922.       Inc(Radius);
  923.   end;
  924.   ChangeTextStyle(TriplexFont, HorizDir, 4);
  925.   SetTextJustify(CenterText, TopText);
  926.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  927.  
  928.   ChangeTextStyle(TriplexFont, HorizDir, 3);
  929.  
  930.   SetFillStyle(SolidFill, RandColor);
  931.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  932.   GetTextCoords(45, Radius, X, Y);
  933.   SetTextJustify(LeftText, BottomText);
  934.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  935.  
  936.   SetFillStyle(HatchFill, RandColor);
  937.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  938.   GetTextCoords(293, Radius, X, Y);
  939.   SetTextJustify(LeftText, TopText);
  940.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  941.  
  942.   SetFillStyle(InterleaveFill, RandColor);
  943.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  944.   GetTextCoords(180, Radius, X, Y);
  945.   SetTextJustify(RightText, CenterText);
  946.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  947.  
  948.   SetFillStyle(WideDotFill, RandColor);
  949.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  950.   GetTextCoords(112, Radius, X, Y);
  951.   SetTextJustify(RightText, BottomText);
  952.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  953.  
  954.   WaitToGo;
  955.   PiePlay := 0;
  956. end; { PiePlay }
  957.  
  958. function Bar3DPlay(UserPointer: pointer): integer;
  959. { Demonstrate Bar3D command }
  960. const
  961.   NumBars   = 7;  { The number of bars drawn }
  962.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  963.   YTicks    = 5;  { The number of tick marks on the Y axis }
  964. var
  965.   ViewInfo : ViewPortType;
  966.   H        : word;
  967.   XStep    : real;
  968.   YStep    : real;
  969.   I, J     : integer;
  970.   Depth    : word;
  971.   Color    : word;
  972. begin
  973.   MainWindow('Bar3D / Rectangle Demostration');
  974.   H := 3*TextHeight('M');
  975.   GetViewSettings(ViewInfo);
  976.   SetTextJustify(CenterText, TopText);
  977.   ChangeTextStyle(TriplexFont, HorizDir, 4);
  978.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  979.   ChangeTextStyle(DefaultFont, HorizDir, 1);
  980.   with ViewInfo do
  981.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  982.   GetViewSettings(ViewInfo);
  983.   with ViewInfo do
  984.   begin
  985.     Line(H, H, H, (y2-y1)-H);
  986.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  987.     YStep := ((y2-y1)-(2*H)) / YTicks;
  988.     XStep := ((x2-x1)-(2*H)) / NumBars;
  989.     J := (y2-y1)-H;
  990.     SetTextJustify(CenterText, CenterText);
  991.  
  992.     { Draw the Y axis and ticks marks }
  993.     for I := 0 to Yticks do
  994.     begin
  995.       Line(H div 2, J, H, J);
  996.       OutTextXY(0, J, Int2Str(I));
  997.       J := Round(J-Ystep);
  998.     end;
  999.  
  1000.  
  1001.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  1002.  
  1003.     { Draw X axis, bars, and tick marks }
  1004.     SetTextJustify(CenterText, TopText);
  1005.     J := H;
  1006.     for I := 1 to Succ(NumBars) do
  1007.     begin
  1008.       SetColor(MaxColor);
  1009.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  1010.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  1011.       if I <> Succ(NumBars) then
  1012.       begin
  1013.         Color := RandColor;
  1014.         SetFillStyle(I, Color);
  1015.         SetColor(Color);
  1016.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  1017.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  1018.         J := Round(J+Xstep);
  1019.       end;
  1020.     end;
  1021.  
  1022.   end;
  1023.   WaitToGo;
  1024.   Bar3DPlay := 0;
  1025. end; { Bar3DPlay }
  1026.  
  1027. function BarPlay(UserPointer: pointer): integer;
  1028. { Demonstrate Bar command }
  1029. const
  1030.   NumBars   = 5;
  1031.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  1032.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  1033. var
  1034.   ViewInfo  : ViewPortType;
  1035.   BarNum    : word;
  1036.   H         : word;
  1037.   XStep     : real;
  1038.   YStep     : real;
  1039.   I, J      : integer;
  1040.   Color     : word;
  1041. begin
  1042.   MainWindow('Bar / Rectangle Demostration');
  1043.   H := 3*TextHeight('M');
  1044.   GetViewSettings(ViewInfo);
  1045.   SetTextJustify(CenterText, TopText);
  1046.   ChangeTextStyle(TriplexFont, HorizDir, 4);
  1047.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  1048.   ChangeTextStyle(DefaultFont, HorizDir, 1);
  1049.   with ViewInfo do
  1050.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  1051.   GetViewSettings(ViewInfo);
  1052.   with ViewInfo do
  1053.   begin
  1054.     Line(H, H, H, (y2-y1)-H);
  1055.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  1056.     YStep := ((y2-y1)-(2*H)) / NumBars;
  1057.     XStep := ((x2-x1)-(2*H)) / NumBars;
  1058.     J := (y2-y1)-H;
  1059.     SetTextJustify(CenterText, CenterText);
  1060.  
  1061.     { Draw Y axis with tick marks }
  1062.     for I := 0 to NumBars do
  1063.     begin
  1064.       Line(H div 2, J, H, J);
  1065.       OutTextXY(0, J, Int2Str(i));
  1066.       J := Round(J-Ystep);
  1067.     end;
  1068.  
  1069.     { Draw X axis, bars, and tick marks }
  1070.     J := H;
  1071.     SetTextJustify(CenterText, TopText);
  1072.     for I := 1 to Succ(NumBars) do
  1073.     begin
  1074.       SetColor(MaxColor);
  1075.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  1076.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  1077.       if I <> Succ(NumBars) then
  1078.       begin
  1079.         Color := RandColor;
  1080.         SetFillStyle(Styles[I], Color);
  1081.         SetColor(Color);
  1082.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1083.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1084.       end;
  1085.       J := Round(J+Xstep);
  1086.     end;
  1087.  
  1088.   end;
  1089.   WaitToGo;
  1090.   BarPlay := 0;
  1091. end; { BarPlay }
  1092.  
  1093. function CirclePlay(UserPointer: pointer): integer;
  1094. { Draw random circles on the screen }
  1095. var
  1096.   MaxRadius : word;
  1097.   _i_       : integer;
  1098. begin
  1099.   MainWindow('Circle Demostration');
  1100.   { StatusLine('Esc aborts or press a key'); }
  1101.   MaxRadius := MaxY div 10;
  1102.   SetLineStyle(SolidLn, 0, NormWidth);
  1103.   for _i_:=1 to 50 do
  1104.   begin
  1105.     SetColor(RandColor);
  1106.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  1107.   end;
  1108.   WaitToGo;
  1109.   CirclePlay := 0;
  1110. end; { CirclePlay }
  1111.  
  1112.  
  1113. function RandBarPlay(UserPointer: pointer): integer;
  1114. { Draw random bars on the screen }
  1115. var
  1116.   MaxWidth  : integer;
  1117.   MaxHeight : integer;
  1118.   ViewInfo  : ViewPortType;
  1119.   Color     : word;
  1120.   _i_       : integer;
  1121. begin
  1122.   MainWindow('Random Bars');
  1123.   { StatusLine('Esc aborts or press a key'); }
  1124.   GetViewSettings(ViewInfo);
  1125.   with ViewInfo do
  1126.   begin
  1127.     MaxWidth := x2-x1;
  1128.     MaxHeight := y2-y1;
  1129.   end;
  1130.   for _i_:=1 to 20 do
  1131.   begin
  1132.     Color := RandColor;
  1133.     SetColor(Color);
  1134.     SetFillStyle(Random(CloseDotFill)+1, Color);
  1135.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1136.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1137.   end;
  1138.   WaitToGo;
  1139.   RandBarPlay := 0;
  1140. end; { RandBarPlay }
  1141.  
  1142. function ArcPlay(UserPointer: pointer): integer;
  1143. { Draw random arcs on the screen }
  1144. var
  1145.   MaxRadius : word;
  1146.   EndAngle : word;
  1147.   ArcInfo : ArcCoordsType;
  1148.   _i_       : integer;
  1149. begin
  1150.   MainWindow('Arc / GetArcCoords Demostration');
  1151.   { StatusLine('Esc aborts or press a key'); }
  1152.   MaxRadius := MaxY div 10;
  1153.   for _i_:=1 to 50 do
  1154.   begin
  1155.     SetColor(RandColor);
  1156.     EndAngle := Random(360);
  1157.     SetLineStyle(SolidLn, 0, NormWidth);
  1158.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  1159.     GetArcCoords(ArcInfo);
  1160.     with ArcInfo do
  1161.     begin
  1162.       Line(X, Y, XStart, YStart);
  1163.       Line(X, Y, Xend, Yend);
  1164.     end;
  1165.   end;
  1166.   WaitToGo;
  1167.   ArcPlay := 0;
  1168. end; { ArcPlay }
  1169.  
  1170. function PutPixelPlay(UserPointer: pointer): integer;
  1171. { Demonstrate the PutPixel and GetPixel commands }
  1172. const
  1173.   Seed   = 1962; { A seed for the random number generator }
  1174.   NumPts = 2000; { The number of pixels plotted }
  1175.   Esc    = #27;
  1176. var
  1177.   I : word;
  1178.   X, Y, Color : word;
  1179.   XMax, YMax  : integer;
  1180.   ViewInfo    : ViewPortType;
  1181.   _i_    : integer;
  1182. begin
  1183.   MainWindow('PutPixel / GetPixel Demostration');
  1184.   { StatusLine('Esc aborts or press a key...'); }
  1185.  
  1186.   GetViewSettings(ViewInfo);
  1187.   with ViewInfo do
  1188.   begin
  1189.     XMax := (x2-x1-1);
  1190.     YMax := (y2-y1-1);
  1191.   end;
  1192.  
  1193.   { for _i_:=1 to 150 do }
  1194.   begin
  1195.     { Plot random pixels }
  1196.     RandSeed := Seed;
  1197.     I := 0;
  1198.     while (not KeyPressed) and (I < NumPts) do
  1199.     begin
  1200.       Inc(I);
  1201.       PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
  1202.     end;
  1203.  
  1204.     { Erase pixels }
  1205.     RandSeed := Seed;
  1206.     I := 0;
  1207.     while (not KeyPressed) and (I < NumPts) do
  1208.     begin
  1209.       Inc(I);
  1210.       X := Random(XMax)+1;
  1211.       Y := Random(YMax)+1;
  1212.       Color := GetPixel(X, Y);
  1213.       if Color = RandColor then
  1214.         PutPixel(X, Y, 0);
  1215.     end;
  1216.   end;
  1217.   WaitToGo;
  1218.   PutPixelPlay := 0;
  1219. end; { PutPixelPlay }
  1220.  
  1221. function PutImagePlay(UserPointer: pointer): integer;
  1222. { Demonstrate the GetImage and PutImage commands }
  1223.  
  1224. const
  1225.   r  = 20;
  1226.   StartX = 100;
  1227.   StartY = 50;
  1228.  
  1229. var
  1230.   CurPort : ViewPortType;
  1231.  
  1232. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  1233. var
  1234.   Step : integer;
  1235. begin
  1236.   Step := Random(2*r);
  1237.   if Odd(Step) then
  1238.     Step := -Step;
  1239.   X := X + Step;
  1240.   Step := Random(r);
  1241.   if Odd(Step) then
  1242.     Step := -Step;
  1243.   Y := Y + Step;
  1244.  
  1245.   { Make saucer bounce off viewport walls }
  1246.   with CurPort do
  1247.   begin
  1248.     if (x1 + X + Width - 1 > x2) then
  1249.       X := x2-x1 - Width + 1
  1250.     else
  1251.       if (X < 0) then
  1252.         X := 0;
  1253.     if (y1 + Y + Height - 1 > y2) then
  1254.       Y := y2-y1 - Height + 1
  1255.     else
  1256.       if (Y < 0) then
  1257.         Y := 0;
  1258.   end;
  1259. end; { MoveSaucer }
  1260.  
  1261. var
  1262.   Pausetime : word;
  1263.   Saucer    : pointer;
  1264.   X, Y      : integer;
  1265.   ulx, uly  : word;
  1266.   lrx, lry  : word;
  1267.   Size      : word;
  1268.   I         : word;
  1269.   _i_       : integer;
  1270. begin
  1271.   ClearDevice;
  1272.   FullPort;
  1273.  
  1274.   { PaintScreen }
  1275.   ClearDevice;
  1276.   MainWindow('GetImage / PutImage Demonstration');
  1277.   { StatusLine('Esc aborts or press a key...'); }
  1278.   GetViewSettings(CurPort);
  1279.  
  1280.   { DrawSaucer }
  1281.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1282.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1283.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1284.   Circle(StartX+10, StartY-12, 2);
  1285.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1286.   Circle(StartX-10, StartY-12, 2);
  1287.   SetFillStyle(SolidFill, MaxColor);
  1288.   FloodFill(StartX+1, StartY+4, GetColor);
  1289.  
  1290.   { ReadSaucerImage }
  1291.   ulx := StartX-(r+1);
  1292.   uly := StartY-14;
  1293.   lrx := StartX+(r+1);
  1294.   lry := StartY+(r div 3)+3;
  1295.  
  1296.   Size := ImageSize(ulx, uly, lrx, lry);
  1297.   GetMem(Saucer, Size);
  1298.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1299.   PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1300.  
  1301.   { Plot some "stars" }
  1302.   for I := 1 to 1000 do
  1303.     PutPixel(Random(MaxX), Random(MaxY), RandColor);
  1304.   X := MaxX div 2;
  1305.   Y := MaxY div 2;
  1306.   PauseTime := 70;
  1307.  
  1308.   { Move the saucer around }
  1309.   for _i_:=1 to 30 do
  1310.   begin
  1311.     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1312.     Delay(PauseTime);
  1313.     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1314.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1315.   end;
  1316.   FreeMem(Saucer, size);
  1317.   WaitToGo;
  1318.   PutImagePlay := 0;
  1319. end; { PutImagePlay }
  1320.  
  1321. function PolyPlay(UserPointer: pointer): integer;
  1322. { Draw random polygons with random fill styles on the screen }
  1323. const
  1324.   MaxPts = 5;
  1325. type
  1326.   PolygonType = array[1..MaxPts] of PointType;
  1327. var
  1328.   Poly : PolygonType;
  1329.   I, Color : word;
  1330.   _i_    : integer;
  1331. begin
  1332.   MainWindow('FillPoly Demostration');
  1333.   { StatusLine('Esc aborts or press a key...'); }
  1334.   for _i_:=1 to 20 do
  1335.   begin
  1336.     Color := RandColor;
  1337.     SetFillStyle(Random(11)+1, Color);
  1338.     SetColor(Color);
  1339.     for I := 1 to MaxPts do
  1340.       with Poly[I] do
  1341.       begin
  1342.         X := Random(MaxX);
  1343.         Y := Random(MaxY);
  1344.       end;
  1345.     FillPoly(MaxPts, Poly);
  1346.   end;
  1347.   WaitToGo;
  1348.   PolyPlay := 0;
  1349. end; { PolyPlay }
  1350.  
  1351. function FillStylePlay(UserPointer: pointer): integer;
  1352. { Display all of the predefined fill styles available }
  1353. var
  1354.   Style    : word;
  1355.   Width    : word;
  1356.   Height   : word;
  1357.   X, Y     : word;
  1358.   I, J     : word;
  1359.   ViewInfo : ViewPortType;
  1360.  
  1361. procedure DrawBox(X, Y : word);
  1362. begin
  1363.   SetFillStyle(Style, MaxColor);
  1364.   with ViewInfo do
  1365.     Bar(X, Y, X+Width, Y+Height);
  1366.   Rectangle(X, Y, X+Width, Y+Height);
  1367.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1368.   Inc(Style);
  1369. end; { DrawBox }
  1370.  
  1371. begin
  1372.   MainWindow('Pre-defined fill styles');
  1373.   GetViewSettings(ViewInfo);
  1374.   with ViewInfo do
  1375.   begin
  1376.     Width := 2 * ((x2+1) div 13);
  1377.     Height := 2 * ((y2-10) div 10);
  1378.   end;
  1379.   X := Width div 2;
  1380.   Y := Height div 2;
  1381.   Style := 0;
  1382.   for J := 1 to 3 do
  1383.   begin
  1384.     for I := 1 to 4 do
  1385.     begin
  1386.       DrawBox(X, Y);
  1387.       Inc(X, (Width div 2) * 3);
  1388.     end;
  1389.     X := Width div 2;
  1390.     Inc(Y, (Height div 2) * 3);
  1391.   end;
  1392.   SetTextJustify(LeftText, TopText);
  1393.   WaitToGo;
  1394.   FillStylePlay := 0;
  1395. end; { FillStylePlay }
  1396.  
  1397. function FillPatternPlay(UserPointer: pointer): integer;
  1398. { Display some user defined fill patterns }
  1399. const
  1400.   Patterns : array[0..11] of FillPatternType = (
  1401.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1402.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1403.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1404.   (0, $10, $28, $44, $28, $10, 0, 0),
  1405.   (0, $70, $20, $27, $25, $27, $4, $4),
  1406.   (0, 0, 0, $18, $18, 0, 0, 0),
  1407.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1408.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1409.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1410.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1411.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1412.   (0, $42, $24, $18, $18, $24, $42, 0));
  1413. var
  1414.   Style    : word;
  1415.   Width    : word;
  1416.   Height   : word;
  1417.   X, Y     : word;
  1418.   I, J     : word;
  1419.   ViewInfo : ViewPortType;
  1420.  
  1421. procedure DrawBox(X, Y : word);
  1422. begin
  1423.   SetFillPattern(Patterns[Style], MaxColor);
  1424.   with ViewInfo do
  1425.     Bar(X, Y, X+Width, Y+Height);
  1426.   Rectangle(X, Y, X+Width, Y+Height);
  1427.   Inc(Style);
  1428. end; { DrawBox }
  1429.  
  1430. begin
  1431.   MainWindow('User defined fill styles');
  1432.   GetViewSettings(ViewInfo);
  1433.   with ViewInfo do
  1434.   begin
  1435.     Width := 2 * ((x2+1) div 13);
  1436.     Height := 2 * ((y2-10) div 10);
  1437.   end;
  1438.   X := Width div 2;
  1439.   Y := Height div 2;
  1440.   Style := 0;
  1441.   for J := 1 to 3 do
  1442.   begin
  1443.     for I := 1 to 4 do
  1444.     begin
  1445.       DrawBox(X, Y);
  1446.       Inc(X, (Width div 2) * 3);
  1447.     end;
  1448.     X := Width div 2;
  1449.     Inc(Y, (Height div 2) * 3);
  1450.   end;
  1451.   SetTextJustify(LeftText, TopText);
  1452.   WaitToGo;
  1453.   FillPatternPlay := 0;
  1454. end; { FillPatternPlay }
  1455.  
  1456. function ColorPlay(UserPointer: pointer): integer;
  1457. { Display all of the colors available for the current driver and mode }
  1458. var
  1459.   Color    : word;
  1460.   Width    : word;
  1461.   Height   : word;
  1462.   X, Y     : word;
  1463.   I, J     : word;
  1464.   ViewInfo : ViewPortType;
  1465.  
  1466. procedure DrawBox(X, Y : word);
  1467. begin
  1468.   SetFillStyle(SolidFill, Color);
  1469.   SetColor(Color);
  1470.   with ViewInfo do
  1471.     Bar(X, Y, X+Width, Y+Height);
  1472.   Rectangle(X, Y, X+Width, Y+Height);
  1473.   Color := GetColor;
  1474.   if Color = 0 then
  1475.   begin
  1476.     SetColor(MaxColor);
  1477.     Rectangle(X, Y, X+Width, Y+Height);
  1478.   end;
  1479.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Color));
  1480.   Color := Succ(Color) mod (MaxColor + 1);
  1481. end; { DrawBox }
  1482.  
  1483. begin
  1484.   MainWindow('Color Demostration');
  1485.   Color := 1;
  1486.   GetViewSettings(ViewInfo);
  1487.   with ViewInfo do
  1488.   begin
  1489.     Width := 2 * ((x2+1) div 16);
  1490.     Height := 2 * ((y2-10) div 10);
  1491.   end;
  1492.   X := Width div 2;
  1493.   Y := Height div 2;
  1494.   for J := 1 to 3 do
  1495.   begin
  1496.     for I := 1 to 5 do
  1497.     begin
  1498.       DrawBox(X, Y);
  1499.       Inc(X, (Width div 2) * 3);
  1500.     end;
  1501.     X := Width div 2;
  1502.     Inc(Y, (Height div 2) * 3);
  1503.   end;
  1504.   WaitToGo;
  1505.   ColorPlay := 0;
  1506. end; { ColorPlay }
  1507.  
  1508. procedure PalettePlay;
  1509. { Demonstrate the use of the SetPalette command }
  1510. const
  1511.   XBars = 15;
  1512.   YBars = 10;
  1513. var
  1514.   I, J     : word;
  1515.   X, Y     : word;
  1516.   Color    : word;
  1517.   ViewInfo : ViewPortType;
  1518.   Width    : word;
  1519.   Height   : word;
  1520.   OldPal   : PaletteType;
  1521. begin
  1522.   GetPalette(OldPal);
  1523.   MainWindow('Palette Demostration');
  1524.   { StatusLine('Press any key...'); }
  1525.   GetViewSettings(ViewInfo);
  1526.   with ViewInfo do
  1527.   begin
  1528.     Width := (x2-x1) div XBars;
  1529.     Height := (y2-y1) div YBars;
  1530.   end;
  1531.   X := 0; Y := 0;
  1532.   Color := 0;
  1533.   for J := 1 to YBars do
  1534.   begin
  1535.     for I := 1 to XBars do
  1536.     begin
  1537.       SetFillStyle(SolidFill, Color);
  1538.       Bar(X, Y, X+Width, Y+Height);
  1539.       Inc(X, Width+1);
  1540.       Inc(Color);
  1541.       Color := Color mod (MaxColor+1);
  1542.     end;
  1543.     X := 0;
  1544.     Inc(Y, Height+1);
  1545.   end;
  1546.   repeat
  1547.     SetPalette(Random(GetMaxColor + 1), Random(65));
  1548.   until KeyPressed;
  1549.   SetAllPalette(OldPal);
  1550.   WaitToGo;
  1551. end; { PalettePlay }
  1552.  
  1553. procedure CrtModePlay;
  1554. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1555. var
  1556.   ViewInfo : ViewPortType;
  1557.   Ch       : char;
  1558. begin
  1559.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1560.   GetViewSettings(ViewInfo);
  1561.   SetTextJustify(CenterText, CenterText);
  1562.   with ViewInfo do
  1563.   begin
  1564.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1565.     StatusLine('Press any key for text mode...');
  1566.     Ch := ReadKey;
  1567.     if ch = #0 then ch := readkey;    { trap function keys }
  1568.     RestoreCrtmode;
  1569.     Writeln('Now you are in text mode.');
  1570.     Write('Press any key to go back to graphics...');
  1571.     Ch := ReadKey;
  1572.     if ch = #0 then ch := readkey;    { trap function keys }
  1573.     SetGraphMode(GetGraphMode);
  1574.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1575.     SetTextJustify(CenterText, CenterText);
  1576.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1577.   end;
  1578.   WaitToGo;
  1579. end; { CrtModePlay }
  1580.  
  1581. function LineStylePlay(UserPointer: pointer): integer;
  1582. { Demonstrate the predefined line styles available }
  1583. var
  1584.   Style    : word;
  1585.   Step     : word;
  1586.   X, Y     : word;
  1587.   ViewInfo : ViewPortType;
  1588.  
  1589. begin
  1590.   ClearDevice;
  1591.   DefaultColors;
  1592.   MainWindow('Pre-defined line styles');
  1593.   GetViewSettings(ViewInfo);
  1594.   with ViewInfo do
  1595.   begin
  1596.     X := 35;
  1597.     Y := 10;
  1598.     Step := (x2-x1) div 11;
  1599.     SetTextJustify(LeftText, TopText);
  1600.     OutTextXY(X, Y, 'NormWidth');
  1601.     SetTextJustify(CenterText, TopText);
  1602.     for Style := 0 to 3 do
  1603.     begin
  1604.       SetLineStyle(Style, 0, NormWidth);
  1605.       Line(X, Y+20, X, Y2-40);
  1606.       OutTextXY(X, Y2-30, Int2Str(Style));
  1607.       Inc(X, Step);
  1608.     end;
  1609.     Inc(X, 2*Step);
  1610.     SetTextJustify(LeftText, TopText);
  1611.     OutTextXY(X, Y, 'ThickWidth');
  1612.     SetTextJustify(CenterText, TopText);
  1613.     for Style := 0 to 3 do
  1614.     begin
  1615.       SetLineStyle(Style, 0, ThickWidth);
  1616.       Line(X, Y+20, X, Y2-40);
  1617.       OutTextXY(X, Y2-30, Int2Str(Style));
  1618.       Inc(X, Step);
  1619.     end;
  1620.   end;
  1621.   SetTextJustify(LeftText, TopText);
  1622.   WaitToGo;
  1623.   LineStylePlay := 0;
  1624. end; { LineStylePlay }
  1625.  
  1626. function UserLineStylePlay(UserPointer: pointer): integer;
  1627. { Demonstrate user defined line styles }
  1628. var
  1629.   Style    : word;
  1630.   X, Y, I  : word;
  1631.   ViewInfo : ViewPortType;
  1632. begin
  1633.   MainWindow('User defined line styles');
  1634.   GetViewSettings(ViewInfo);
  1635.   with ViewInfo do
  1636.   begin
  1637.     X := 4;
  1638.     Y := 10;
  1639.     Style := 0;
  1640.     I := 0;
  1641.     while X < X2-4 do
  1642.     begin
  1643.       {$B+}
  1644.       Style := Style or (1 shl (I mod 16));
  1645.       {$B-}
  1646.       SetLineStyle(UserBitLn, Style, NormWidth);
  1647.       Line(X, Y, X, (y2-y1)-Y);
  1648.       Inc(X, 5);
  1649.       Inc(I);
  1650.       if Style = 65535 then
  1651.       begin
  1652.         I := 0;
  1653.         Style := 0;
  1654.       end;
  1655.     end;
  1656.   end;
  1657.   WaitToGo;
  1658.   UserLineStylePlay := 0;
  1659. end; { UserLineStylePlay }
  1660.  
  1661.  
  1662. procedure SayGoodbye;
  1663. { Say goodbye and then exit the program }
  1664. var
  1665.   ViewInfo : ViewPortType;
  1666. begin
  1667.   MainWindow('');
  1668.   GetViewSettings(ViewInfo);
  1669.   ChangeTextStyle(TriplexFont, HorizDir, 4);
  1670.   SetTextJustify(CenterText, CenterText);
  1671.   with ViewInfo do
  1672.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1673.   StatusLine('Press any key to quit...');
  1674.   repeat until KeyPressed;
  1675. end; { SayGoodbye }
  1676.  
  1677. begin { program body }
  1678.   PRT_Initialize;
  1679.   Initialize;
  1680.  
  1681.   DrawAndPrint(ReportStatus);
  1682.  
  1683.   DrawAndPrint(AspectRatioPlay);
  1684.   DrawAndPrint(FillEllipsePlay);
  1685.   DrawAndPrint(SectorPlay);
  1686.   DrawAndPrint(WriteModePlay);
  1687.  
  1688.   DrawAndPrint(ColorPlay);
  1689.   { PalettePlay only intended to work on these drivers: }
  1690.   if (GraphDriver = EGA) or
  1691.      (GraphDriver = EGA64) or
  1692.      (GraphDriver = VGA) then
  1693.     PalettePlay;
  1694.   DrawAndPrint(PutPixelPlay);
  1695.   DrawAndPrint(PutImagePlay);
  1696.   DrawAndPrint(RandBarPlay);
  1697.   DrawAndPrint(BarPlay);
  1698.   DrawAndPrint(Bar3DPlay);
  1699.   DrawAndPrint(ArcPlay);
  1700.   DrawAndPrint(CirclePlay);
  1701.   DrawAndPrint(PiePlay);
  1702.   DrawAndPrint(LineToPlay);
  1703.   DrawAndPrint(LineRelPlay);
  1704.   DrawAndPrint(LineStylePlay);
  1705.   DrawAndPrint(UserLineStylePlay);
  1706.   TextDump;
  1707.   DrawAndPrint(TextPlay);
  1708.   CrtModePlay;
  1709.   DrawAndPrint(FillStylePlay);
  1710.   DrawAndPrint(FillPatternPlay);
  1711.   DrawAndPrint(PolyPlay);
  1712.   SayGoodbye;
  1713.   CloseGraph;
  1714. end.
  1715.